home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / trace.lsp < prev   
Lisp/Scheme  |  1987-06-04  |  9KB  |  259 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;        trace.lsp
  6. ;;;;
  7. ;;;;        Tracer package for Common Lisp
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12. (export '(trace untrace))
  13. (export 'step)
  14.  
  15.  
  16. (in-package 'system)
  17.  
  18.  
  19. (proclaim '(optimize (safety 2) (space 3)))
  20.  
  21.  
  22. (defvar *trace-level* 0)
  23. (defvar *trace-list* nil)
  24.  
  25.  
  26. (defmacro trace (&rest r)
  27.   (if (null r)
  28.       '*trace-list*
  29.       `(mapcan #'trace-one ',r)))
  30.  
  31. (defmacro untrace (&rest r)
  32.   (if (null r)
  33.       '(mapcan #'untrace-one *trace-list*)
  34.       `(mapcan #'untrace-one ',r)))
  35.  
  36. (defun trace-one (fname &aux f)
  37.   (when (null (fboundp fname))
  38.         (format *trace-output* "The function ~S is not defined.~%" fname)
  39.         (return-from trace-one nil))
  40.   (when (special-form-p fname)
  41.         (format *trace-output* "~S is a special form.~%" fname)
  42.         (return-from trace-one nil))
  43.   (when (macro-function fname)
  44.         (format *trace-output* "~S is a macro.~%" fname)
  45.         (return-from trace-one nil))
  46.   (when (get fname 'traced)
  47.         (cond ((and (consp (symbol-function fname))
  48.                     (consp (nth 3 (symbol-function fname)))
  49.                     (eq (car (nth 3 (symbol-function fname))) 'trace-call))
  50.                (format *trace-output*
  51.                        "The function ~S is already traced.~%" fname)
  52.                (return-from trace-one nil))
  53.               (t (untrace-one fname))))
  54.   (si:fset (setq f (gensym)) (symbol-function fname))
  55.   (si:putprop fname f 'traced)
  56.   (eval `(defun ,fname (&rest args) (trace-call ',fname ',f args)))
  57.   (setq *trace-list* (cons fname *trace-list*))
  58.   (list fname))
  59.  
  60. (defun trace-call (fname temp-name args
  61.                    &aux (*trace-level* *trace-level*) values indent)
  62.   (setq *trace-level* (1+ *trace-level*))
  63.   (setq indent (min (* *trace-level* 2) 20))
  64.   (fresh-line *trace-output*)
  65.   (format *trace-output*
  66.           "~V@T~D> ~S~%"
  67.           indent *trace-level* (cons fname args))
  68.   (setq values (multiple-value-list (apply temp-name args)))
  69.   (fresh-line *trace-output*)
  70.   (format *trace-output*
  71.           "~V@T<~D ~S~%"
  72.           indent
  73.           *trace-level*
  74.           (cons fname values))
  75.   (setq *trace-level* (1- *trace-level*))
  76.   (values-list values))
  77.  
  78.  
  79. (defun untrace-one (fname)
  80.   (cond ((get fname 'traced)
  81.          (if (and (consp (symbol-function fname))
  82.                   (consp (nth 3 (symbol-function fname)))
  83.                   (eq (car (nth 3 (symbol-function fname))) 'trace-call)
  84.                   ; (LAMBDA-BLOCK block-name lambda-list (TRACE-CALL ... ))
  85.                   )
  86.              (si:fset fname (symbol-function (get fname 'traced)))
  87.              (format *trace-output*
  88.                      "The function ~S was traced, but redefined.~%"
  89.                      fname))
  90.          (remprop fname 'traced)
  91.          (setq *trace-list* (list-delq fname *trace-list*))
  92.          (list fname))
  93.         (t
  94.          (format *trace-output* "The function ~S is not traced.~%" fname)
  95.          nil)))
  96.  
  97.  
  98. (defvar *step-level* 0)
  99. (defvar *step-quit* nil)
  100. (defvar *step-function* nil)
  101.  
  102. (defvar *old-print-level* nil)
  103. (defvar *old-print-length* nil)
  104.  
  105.  
  106. (defun step-read-line ()
  107.   (do ((char (read-char *debug-io*) (read-char *debug-io*)))
  108.       ((or (char= char #\Newline) (char= char #\Return)))))
  109.  
  110. (defmacro if-error (error-form form)
  111.   (let ((v (gensym)) (f (gensym)) (b (gensym)))
  112.     `(let (,v ,f)
  113.        (block ,b
  114.          (unwind-protect (setq ,v ,form ,f t)
  115.            (return-from ,b (if ,f ,v ,error-form)))))))
  116.  
  117. (defmacro step (form)
  118.   `(let* ((*old-print-level* *print-level*)
  119.           (*old-print-length* *print-length*)
  120.           (*print-level* 2)
  121.           (*print-length* 2))
  122.      (read-line)
  123.      (format *debug-io* "Type ? and a newline for help.~%")
  124.      (setq *step-quit* nil)
  125.      (stepper ',form nil)))
  126.  
  127. (defun stepper (form &optional env
  128.                 &aux values (*step-level* *step-level*) indent)
  129.   (when (eq *step-quit* t)
  130.     (return-from stepper (evalhook form nil nil env)))
  131.   (when (numberp *step-quit*)
  132.     (if (>= (1+ *step-level*) *step-quit*)
  133.         (return-from stepper (evalhook form nil nil env))
  134.         (setq *step-quit* nil)))
  135.   (when *step-function*
  136.     (if (and (consp form) (eq (car form) *step-function*))
  137.         (let ((*step-function* nil))
  138.           (return-from stepper (stepper form env)))
  139.         (return-from stepper (evalhook form #'stepper nil env))))
  140.   (setq *step-level* (1+ *step-level*))
  141.   (setq indent (min (* *step-level* 2) 20))
  142.   (loop
  143.     (format *debug-io* "~VT~S " indent form)
  144.     (finish-output *debug-io*)
  145.     (case (do ((char (read-char *debug-io*) (read-char *debug-io*)))
  146.               ((and (char/= char #\Space) (char/= char #\Tab)) char))
  147.           ((#\Newline #\Return)
  148.            (setq values
  149.                  (multiple-value-list
  150.                   (evalhook form #'stepper nil env)))
  151.            (return))
  152.           ((#\n #\N)
  153.            (step-read-line)
  154.            (setq values
  155.                  (multiple-value-list
  156.                   (evalhook form #'stepper nil env)))
  157.            (return))
  158.           ((#\s #\S)
  159.            (step-read-line)
  160.            (setq values
  161.                  (multiple-value-list
  162.                   (evalhook form nil nil env)))
  163.            (return))
  164.           ((#\p #\P)
  165.            (step-read-line)
  166.            (write form
  167.                   :stream *debug-io*
  168.                   :pretty t :level nil :length nil)
  169.            (terpri))
  170.           ((#\f #\F)
  171.            (let ((*step-function*
  172.                   (if-error nil
  173.                             (prog1 (read-preserving-whitespace *debug-io*)
  174.                                    (step-read-line)))))
  175.              (setq values
  176.                    (multiple-value-list
  177.                     (evalhook form #'stepper nil env)))
  178.              (return)))
  179.           ((#\q #\Q)
  180.            (step-read-line)
  181.            (setq *step-quit* t)
  182.            (setq values
  183.                  (multiple-value-list
  184.                   (evalhook form nil nil env)))
  185.            (return))
  186.           ((#\u #\U)
  187.            (step-read-line)
  188.            (setq *step-quit* *step-level*)
  189.            (setq values
  190.                  (multiple-value-list
  191.                   (evalhook form nil nil env)))
  192.            (return))
  193.           ((#\e #\E)
  194.            (let ((env1 env))
  195.              (dolist (x
  196.                       (if-error nil
  197.                                 (multiple-value-list
  198.                                  (evalhook
  199.                                   (if-error nil
  200.                                             (prog1
  201.                                              (read-preserving-whitespace
  202.                                               *debug-io*)
  203.                                              (step-read-line)))
  204.                                   nil nil env1))))
  205.                      (write x
  206.                             :stream *debug-io*
  207.                             :level *old-print-level*
  208.                             :length *old-print-length*)
  209.                      (terpri *debug-io*))))
  210.           ((#\r #\R)
  211.            (let ((env1 env))
  212.              (setq values
  213.                    (if-error nil
  214.                              (multiple-value-list
  215.                               (evalhook
  216.                                (if-error nil
  217.                                          (prog1
  218.                                           (read-preserving-whitespace
  219.                                            *debug-io*)
  220.                                           (step-read-line)))
  221.                                nil nil env1)))))
  222.            (return))
  223.           ((#\b #\B)
  224.            (step-read-line)
  225.            (let ((*ihs-base* (1+ *ihs-top*))
  226.                  (*ihs-top* (1- (ihs-top)))
  227.                  (*current-ihs* *ihs-top*))
  228.              (backtrace)))
  229.           (t
  230.            (step-read-line)
  231.            (terpri)
  232.            (format *debug-io*
  233.                   "Stepper commands:~%~
  234.         n (or N or Newline):    advances to the next form.~%~
  235.         s (or S):        skips the form.~%~
  236.         p (or P):        pretty-prints the form.~%~
  237.                 f (or F) FUNCTION:    skips until the FUNCTION is called.~%~
  238.                 q (or Q):        quits.~%~
  239.                 u (or U):        goes up to the enclosing form.~%~
  240.                 e (or E) FORM:        evaluates the FORM ~
  241.                     and prints the value(s).~%~
  242.                 r (or R) FORM:        evaluates the FORM ~
  243.                     and returns the value(s).~%~
  244.                 b (or B):        prints backtrace.~%~
  245.         ?:            prints this.~%")
  246.            (terpri))))
  247.   (when (or (constantp form) (and (consp form) (eq (car form) 'quote)))
  248.         (return-from stepper (car values)))
  249.   (if (endp values)
  250.       (format *debug-io* "~V@T=~%" indent)
  251.       (do ((l values (cdr l))
  252.            (b t nil))
  253.           ((endp l))
  254.         (if b
  255.             (format *debug-io* "~V@T= ~S~%" indent (car l))
  256.             (format *debug-io* "~V@T& ~S~%" indent (car l)))))
  257.   (setq *step-level* (- *step-level* 1))
  258.   (values-list values))
  259.